home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Visual Basic Toolbox
/
Visual Basic Toolbox (P.I.E.)(1996).ISO
/
reports
/
filetrns
/
download.frm
< prev
next >
Wrap
Text File
|
1995-12-08
|
31KB
|
978 lines
VERSION 2.00
Begin Form frmDownLoad
BorderStyle = 3 'Fixed Double
Caption = "Download Records"
ClientHeight = 4650
ClientLeft = 315
ClientTop = 1635
ClientWidth = 9075
Height = 5055
Icon = DOWNLOAD.FRX:0000
Left = 255
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 540
ScaleWidth = 540
Top = 1290
Width = 9195
Begin Frame Frame1
Caption = "Session"
Height = 2355
Left = 60
TabIndex = 18
Top = 60
Width = 4455
Begin ComboBox cboSystems
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 300
Left = 120
Style = 2 'Dropdown List
TabIndex = 3
Top = 1380
Width = 1695
End
Begin OptionButton optRetrieve
Alignment = 1 'Right Justify
Caption = "Retrieve Count"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 315
Index = 2
Left = 2640
TabIndex = 37
Top = 1920
Width = 1695
End
Begin OptionButton optRetrieve
Alignment = 1 'Right Justify
Caption = "Retrieve Records"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 315
Index = 0
Left = 2640
TabIndex = 6
Top = 1320
Width = 1695
End
Begin OptionButton optRetrieve
Alignment = 1 'Right Justify
Caption = "Retrieve Templates"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 315
Index = 1
Left = 2640
TabIndex = 7
Top = 1620
Width = 1695
End
Begin CommandButton cmdClose
Caption = "Close"
Enabled = 0 'False
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 435
Left = 3480
TabIndex = 5
Top = 780
Width = 855
End
Begin TextBox txtFile
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 285
Left = 1260
TabIndex = 1
Top = 840
Width = 1035
End
Begin TextBox txtLibrary
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 285
Left = 120
TabIndex = 0
Top = 840
Width = 1095
End
Begin TextBox txtMember
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 285
Left = 2340
TabIndex = 2
Top = 840
Width = 1035
End
Begin CommandButton cmdOpen
Caption = "Open"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 435
Left = 3480
TabIndex = 4
Top = 300
Width = 855
End
Begin Label zlbl
BackStyle = 0 'Transparent
Caption = "System:"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 225
Index = 12
Left = 120
TabIndex = 38
Top = 1170
Width = 615
End
Begin Label zlbl
Alignment = 1 'Right Justify
BackColor = &H00FFFFFF&
BackStyle = 0 'Transparent
Caption = "Number Of Fields:"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
ForeColor = &H00000000&
Height = 255
Index = 6
Left = 120
TabIndex = 20
Top = 1980
Width = 1335
End
Begin Label lblNumFields
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 255
Left = 1500
TabIndex = 21
Top = 1980
Width = 795
End
Begin Label zlbl
Alignment = 1 'Right Justify
BackColor = &H00FFFFFF&
BackStyle = 0 'Transparent
Caption = "Conversation ID:"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
ForeColor = &H00000000&
Height = 255
Index = 7
Left = 120
TabIndex = 22
Top = 1740
Width = 1335
End
Begin Label lblConvID
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 255
Left = 1500
TabIndex = 23
Top = 1740
Width = 915
End
Begin Label zlbl
Alignment = 2 'Center
BackColor = &H00800000&
Caption = "File"
ForeColor = &H00FFFFFF&
Height = 255
Index = 1
Left = 1260
TabIndex = 24
Top = 600
Width = 1035
End
Begin Label zlbl
Alignment = 2 'Center
BackColor = &H00800000&
Caption = "Library"
ForeColor = &H00FFFFFF&
Height = 255
Index = 0
Left = 120
TabIndex = 25
Top = 600
Width = 1095
End
Begin Label zlbl
Alignment = 2 'Center
BackColor = &H00800000&
Caption = "Member"
ForeColor = &H00FFFFFF&
Height = 255
Index = 2
Left = 2340
TabIndex = 26
Top = 600
Width = 1035
End
Begin Label lblSessionStatus
Alignment = 2 'Center
BackColor = &H000000FF&
BorderStyle = 1 'Fixed Single
Caption = "Transfer Session Closed"
Height = 255
Left = 120
TabIndex = 28
Top = 300
Width = 3255
End
End
Begin Frame fraReturned
Caption = "Information Returned"
Height = 3555
Left = 4560
TabIndex = 29
Top = 60
Width = 4455
Begin TextBox txtReturned
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 2355
Left = 60
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 32
TabStop = 0 'False
Top = 1140
Width = 4335
End
Begin Label lblReturned
Alignment = 2 'Center
BackColor = &H00800000&
Caption = "Error Message"
ForeColor = &H00FFFFFF&
Height = 255
Left = 60
TabIndex = 33
Top = 900
Width = 4335
End
Begin Label zlbl
Alignment = 1 'Right Justify
BackColor = &H00FFFFFF&
BackStyle = 0 'Transparent
Caption = "API Return Code:"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
ForeColor = &H00000000&
Height = 255
Index = 8
Left = 60
TabIndex = 36
Top = 300
Width = 1275
End
Begin Label lblReturnCode
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 255
Left = 1380
TabIndex = 19
Top = 300
Width = 735
End
Begin Label zlbl
Alignment = 1 'Right Justify
BackColor = &H00FFFFFF&
BackStyle = 0 'Transparent
Caption = "Blocks Written:"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
ForeColor = &H00000000&
Height = 255
Index = 4
Left = 2160
TabIndex = 35
Top = 600
Width = 1155
End
Begin Label zlbl
Alignment = 1 'Right Justify
BackColor = &H00FFFFFF&
BackStyle = 0 'Transparent
Caption = "Records Read:"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
ForeColor = &H00000000&
Height = 255
Index = 3
Left = 2160
TabIndex = 34
Top = 300
Width = 1155
End
Begin Label lblBlocksWritten
Alignment = 2 'Center
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 255
Left = 3360
TabIndex = 31
Top = 600
Width = 735
End
Begin Label lblRecordsRead
Alignment = 2 'Center
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 255
Left = 3360
TabIndex = 30
Top = 300
Width = 735
End
End
Begin Frame fraConversion
Caption = "Retrieval"
Height = 2175
Left = 60
TabIndex = 27
Top = 2400
Width = 4455
Begin CommandButton cmdStart
Caption = "Start"
Enabled = 0 'False
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 435
Left = 3480
TabIndex = 14
Top = 180
Width = 855
End
Begin CommandButton cmdEnd
Caption = "End"
Enabled = 0 'False
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 435
Left = 3480
TabIndex = 15
Top = 660
Width = 855
End
Begin CheckBox chkHandleNulls
Alignment = 1 'Right Justify
Caption = "Handle Null Fields"
Height = 315
Left = 2460
TabIndex = 13
Top = 1800
Width = 1875
End
Begin OptionButton optConversion
Caption = "DOS Random Type 2, with Exceptions"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 372
Index = 4
Left = 60
TabIndex = 12
Top = 1440
Width = 3012
End
Begin OptionButton optConversion
Caption = "DOS Random Type 2"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 375
Index = 3
Left = 60
TabIndex = 10
Top = 840
Width = 1875
End
Begin OptionButton optConversion
Caption = "DOS Random, with Exceptions"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 375
Index = 2
Left = 60
TabIndex = 11
Top = 1140
Width = 2535
End
Begin OptionButton optConversion
Caption = "DOS Random"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 375
Index = 1
Left = 60
TabIndex = 9
Top = 540
Width = 1875
End
Begin OptionButton optConversion
Caption = "No Conversion"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 375
Index = 0
Left = 60
TabIndex = 8
Top = 240
Width = 1875
End
End
Begin CommandButton cmdAbout
Caption = "&About"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 435
Left = 8100
TabIndex = 16
Top = 3660
Width = 855
End
Begin CommandButton cmdExit
Caption = "E&xit"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 435
Left = 8100
TabIndex = 17
Top = 4140
Width = 855
End
End
Option Explicit
' Constants:
Const sSTATUS_OFF = "Transfer Session Closed"
Const sSTATUS_ON = "Transfer Session Open"
' Variables:
Dim bStopRetrieval As Integer ' stop retrieval
Dim lTFConvID As Long ' conversation ID
Dim lRecordsRead As Long ' records read
Dim nBlocksWritten As Integer ' blocks written
Dim nFileNumber As Integer ' open file number
Dim nRC As Integer ' API return code
Dim sRecord As String ' record read
Dim sRecordsToBeWritten As String ' records to be written to disk
Dim sSystem As String ' AS/400 system name
Sub cmdAbout_Click ()
' display about message
gsMBText = "This program will download a file from your AS/400"
gsMBText = gsMBText & " into an ASCII text file called DOWNLOAD.TXT"
gsMBText = gsMBText & " or field information into a file called TEMPLATE.TXT."
MsgBox gsMBText
End Sub
Sub cmdClose_Click ()
Call SessionClose
End Sub
Sub cmdEnd_Click ()
' end current retrieval process
bStopRetrieval = True
' cannot end any more
cmdStart.Enabled = True
cmdEnd.Enabled = False
End Sub
Sub cmdExit_Click ()
' unload form
If MsgBox("Do You Want To End The Program?", MB_ICONQUESTION Or MB_YESNO) = IDYES Then Unload Me
End Sub
Sub cmdOpen_Click ()
' open file transfer session
Call SessionOpen
End Sub
Sub cmdStart_Click ()
' retrieving records or templates
Call RetrieveStart
End Sub
Sub Form_Load ()
' set global variables
Call zzSetGlobalVariables
' center form
zzFormCenter Me
' setup program title
App.Title = "Download Records"
' put list of systems into control
Call zzCAPutSystemListIntoCtrl(Me.hWnd, cboSystems)
' turn on options
optRetrieve(0) = True
optConversion(0) = True
chkHandleNulls = False
lblReturned = "This Area Will Display Error Messages And Data"
' assume session closed
Call SessionClose
End Sub
Sub Form_Unload (Cancel As Integer)
' close open session
Call SessionClose
' end program
End
End Sub
Sub RetrieveStart ()
' Description:
' Retrieve records or templates
' Parameters:
' bRetrieveRecords retrieve records
' Variables:
Dim nTFConversion As Integer ' conversion option
Dim bRetrieveCount As Integer ' retrieving count?
Dim bRetrieveRecords As Integer ' retrieving records
' template information
Dim nFieldDecimalPos As Integer
Dim nFieldDigits As Integer
Dim nFieldLength As Integer
Dim nFieldNullCapable As Integer
Dim nFieldType As Integer
Dim nFieldVariableLength As Integer
Dim sFieldName As String
' are we retrieving records
bRetrieveRecords = ((optRetrieve(0) <> False) Or (optRetrieve(2) <> False))
' are we getting a count of records
bRetrieveCount = (optRetrieve(2) <> False)
nFileNumber = FreeFile
' open download file if just retrieving records
If bRetrieveRecords And Not bRetrieveCount Then
Open App.Path & "\DOWNLOAD.TXT" For Output As nFileNumber
lblReturned = "Current Record"
' do nothing if getting count
ElseIf bRetrieveCount Then
lblReturned = "Record Count"
' open template file
Else
Open App.Path & "\TEMPLATE.TXT" For Output As nFileNumber
lblReturned = "Current Template"
End If
' clear storage field, counters
sRecordsToBeWritten = gsEMPTY
nBlocksWritten = 0: lRecordsRead = 0
' determine conversion option
If optConversion(0) Then
nTFConversion = gnTF_NO_CONVERSION
ElseIf optConversion(1) Then
nTFConversion = gnTF_DOS_RANDOM
ElseIf optConversion(2) Then
nTFConversion = gnTF_DOS_RANDOM2
ElseIf optConversion(3) Then
nTFConversion = gnTF_DOS_RANDOM_EXCEPT
ElseIf optConversion(4) Then
nTFConversion = gnTF_DOS_RANDOM2_EXCEPT
End If
' handle nulls
If chkHandleNulls Then
nTFConversion = nTFConversion + &H80
End If
' no conversion if getting count
If bRetrieveCount Then
nTFConversion = gnTF_NO_CONVERSION
End If
' start current retrieval process
bStopRetrieval = False
cmdStart.Enabled = False
cmdEnd.Enabled = True
Do
' give windows time
DoEvents
' stop current retrieval process
If bStopRetrieval Then Exit Do
' retrieve record
If bRetrieveRecords Then
nRC = zzTFGetRecord(Me.hWnd, 0, lTFConvID, cboSystems.Text, nTFConversion, sRecord)
' retrieve template
Else
nRC = zzTFGetTemplate(Me.hWnd, 0, lTFConvID, cboSystems.Text, sRecord)
' break down field specs
Call zzTFParseTemplate(sRecord, sFieldName, nFieldType, nFieldDigits, nFieldDecimalPos, nFieldLength, nFieldNullCapable, nFieldVariableLength)
sRecord = sFieldName & ", Length:"
sRecord = sRecord & Format$(nFieldLength) & "."
sRecord = sRecord & Format$(nFieldDecimalPos) & ", Type:"
sRecord = sRecord & Format$(nFieldType)
End If
' show return code
lblReturnCode = Hex$(nRC)
' if EOF then exit
If nRC = gnTF_EOF Then Exit Do
' if any other error except untranslatable data then exit
If nRC <> gnTF_OK And nRC <> gnTF_UNXLATABLE_DATA Then Exit Do
' increment and show counter
lRecordsRead = lRecordsRead + 1
lblRecordsRead = Format$(lRecordsRead)
' convert the count of records
If bRetrieveCount Then
sRecord = zzCV_Bin4ToASCII(Me.hWnd, sRecord) & " records in file."
End If
' show data returned
txtReturned = sRecord
' add to storage area with EOL stuff
sRecordsToBeWritten = sRecordsToBeWritten & sRecord & gsCHR_CR & gsCHR_LF
' if big enough then write it out
If Len(sRecordsToBeWritten) > 10000 Then
Print #nFileNumber, sRecordsToBeWritten;
sRecordsToBeWritten = gsEMPTY
nBlocksWritten = nBlocksWritten + 1
lblBlocksWritten = Format$(nBlocksWritten)
End If
Loop
' handle errors
On Error Resume Next
' write out any left over data
If sRecordsToBeWritten <> gsEMPTY Then
Print #nFileNumber, sRecordsToBeWritten
End If
' close the output file
Close nFileNumber
' end retrieval
cmdEnd = True
End Sub
Sub SessionClose ()
MousePointer = HOURGLASS
' if session already open then
If lTFConvID <> 0 Then
' close any active transfer requests
nRC = zzTFClose(Me.hWnd, 0, lTFConvID, cboSystems.Text)
' end conversation
nRC = zzTFEndConversation(Me.hWnd, 0, lTFConvID, cboSystems.Text)
' turn status flag off
lblSessionStatus = sSTATUS_OFF
lblSessionStatus.BackColor = RED
' reset conversation ID
lTFConvID = 0
' cannot open again
cmdOpen.Enabled = True
cboSystems.Enabled = True
cmdClose.Enabled = False
cmdStart.Enabled = False
cmdEnd.Enabled = False
End If
' display returned information
If lTFConvID = 0 Then
lblConvID = gsEMPTY
Else
lblConvID = Format$(lTFConvID)
End If
If nRC = gnTF_OK Then
lblReturnCode = gsEMPTY
Else
lblReturnCode = Hex$(nRC)
End If
lblNumFields = gsEMPTY
txtReturned = gsEMPTY
lblRecordsRead = gsEMPTY
lblBlocksWritten = gsEMPTY
MousePointer = DEFAULT
End Sub
Sub SessionOpen ()
' Description:
' Open transfer session
' Variables:
Dim nTFNumTemplates As Integer ' number of templates
Dim sSelectStatement As String ' select statement
Dim sSelectStatementSent As String ' select statement
' close current session
Call SessionClose
' must have library name
If cboSystems.Text = gsEMPTY Then
gsMBText = "AS/400 system required."
MsgBox gsMBText, MB_ICONSTOP
cboSystems.SetFocus
Else
' must have library name
If txtLibrary = gsEMPTY Then
gsMBText = "Library name required."
MsgBox gsMBText, MB_ICONSTOP
txtLibrary.SetFocus
Else
' must have file name
If txtFile = gsEMPTY Then
gsMBText = "File name required."
MsgBox gsMBText, MB_ICONSTOP
txtFile.SetFocus
Else
' please wait
MousePointer = HOURGLASS
' just getting count of records
If optRetrieve(2) = True Then
sSelectStatement = "SELECT COUNT(*) FROM " & UCase$(txtLibrary) & "/" & UCase$(txtFile)
' getting templates or records
Else
sSelectStatement = "SELECT * FROM " & UCase$(txtLibrary) & "/" & UCase$(txtFile)
End If
' add member information
If txtMember <> gsEMPTY Then
sSelectStatement = sSelectStatement & " (" & UCase$(txtMember) & ")"
End If
' place in select statement to send
sSelectStatementSent = sSelectStatement
' send SELECT statement to host
nRC = zzTFOpen(Me.hWnd, 0, lTFConvID, sSelectStatement, cboSystems.Text, nTFNumTemplates)
' no more waiting
MousePointer = DEFAULT
' show resulting select statement
If nRC = gnTF_OK Then
lblReturned = "Formatted Select Statement"
txtReturned = sSelectStatement
Else
lblReturned = "Error Message"
If sSelectStatementSent <> sSelectStatement Then
txtReturned = sSelectStatement
Else
txtReturned = gsEMPTY
End If
End If
' display return information
lblConvID = Format$(lTFConvID)
lblReturnCode = Hex$(nRC)
If nRC = gnTF_OK Then
lblNumFields = Format$(nTFNumTemplates)
Else
lblNumFields = gsEMPTY
End If
If lTFConvID <> 0 Then
' turn status flag on
lblSessionStatus = sSTATUS_ON
lblSessionStatus.BackColor = GREEN
' cannot open again
cmdOpen.Enabled = False
cboSystems.Enabled = False
cmdClose.Enabled = True
cmdStart.Enabled = True
End If
End If
End If
End If
End Sub